home *** CD-ROM | disk | FTP | other *** search
/ Aminet 52 / Aminet 52 (2002)(GTI - Schatztruhe)[!][Dec 2002].iso / Aminet / dev / gg / ncurses-5.3.lha / ncurses-5.3 / Ada95 / samples / ncurses2-getopt.adb < prev    next >
Text File  |  2002-10-24  |  7KB  |  169 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                       GNAT ncurses Binding Samples                       --
  4. --                                                                          --
  5. --                                 ncurses                                  --
  6. --                                                                          --
  7. --                                 B O D Y                                  --
  8. --                                                                          --
  9. ------------------------------------------------------------------------------
  10. -- Copyright (c) 2000 Free Software Foundation, Inc.                        --
  11. --                                                                          --
  12. -- Permission is hereby granted, free of charge, to any person obtaining a  --
  13. -- copy of this software and associated documentation files (the            --
  14. -- "Software"), to deal in the Software without restriction, including      --
  15. -- without limitation the rights to use, copy, modify, merge, publish,      --
  16. -- distribute, distribute with modifications, sublicense, and/or sell       --
  17. -- copies of the Software, and to permit persons to whom the Software is    --
  18. -- furnished to do so, subject to the following conditions:                 --
  19. --                                                                          --
  20. -- The above copyright notice and this permission notice shall be included  --
  21. -- in all copies or substantial portions of the Software.                   --
  22. --                                                                          --
  23. -- THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS  --
  24. -- OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF               --
  25. -- MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.   --
  26. -- IN NO EVENT SHALL THE ABOVE COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM,   --
  27. -- DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR    --
  28. -- OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR    --
  29. -- THE USE OR OTHER DEALINGS IN THE SOFTWARE.                               --
  30. --                                                                          --
  31. -- Except as contained in this notice, the name(s) of the above copyright   --
  32. -- holders shall not be used in advertising or otherwise to promote the     --
  33. -- sale, use or other dealings in this Software without prior written       --
  34. -- authorization.                                                           --
  35. ------------------------------------------------------------------------------
  36. --  Author: Eugene V. Melaragno <aldomel@ix.netcom.com> 2000
  37. --  Version Control
  38. --  $Revision: 1.2 $
  39. --  Binding Version 01.00
  40. ------------------------------------------------------------------------------
  41. --  A simplified version of the  GNU getopt function
  42. --  copyright Free Software Foundtion
  43.  
  44. with Ada.Strings.Fixed;
  45. with Ada.Strings.Bounded;
  46. with Ada.Text_IO; use Ada.Text_IO;
  47.  
  48. package body ncurses2.getopt is
  49.  
  50.    opterr : Character := Character'Val (1);
  51.    optopt : Character := '?';
  52.    initialized : Boolean := False;
  53.  
  54.    nextchar : Natural := 0;
  55.  
  56.    --  Ncurses doesn't use the non option elements so we are spared
  57.    --  the job of computing those.
  58.  
  59.    --  also the user is not allowed to modify argv or argc
  60.    --  Doing so is Erroneous execution.
  61.  
  62.    --  longoptions are not handled.
  63.  
  64.    procedure Qgetopt (retval : out Integer;
  65.                       argc : Integer;
  66.                       argv : stringfunc;
  67.                         --  argv will be the Argument function.
  68.                       optstring : String;
  69.                       optind : in out Integer;
  70.                         --  ignored for ncurses, must be initialized to 1 by
  71.                         --  the caller
  72.                       Optarg : out stringa
  73.                         --  a garbage colector would be useful here.
  74.                      ) is
  75.  
  76.       package BS is new Ada.Strings.Bounded.Generic_Bounded_Length (200);
  77.       use BS;
  78.       optargx : Bounded_String;
  79.    begin
  80.  
  81.       if argc < optind then
  82.          retval := -1;
  83.          return;
  84.       end if;
  85.  
  86.       optargx := To_Bounded_String ("");
  87.  
  88.       if nextchar = 0 then
  89.  
  90.          if argv (optind) = "--" then
  91.                            --  the rest are non-options, we ignore them
  92.             retval := -1;
  93.             return;
  94.          end if;
  95.  
  96.          if argv (optind)(1) /= '-' or argv (optind)'Length = 1 then
  97.             optind := optind + 1;
  98.             Optarg := new String'(argv (optind));
  99.             retval := 1;
  100.             return;
  101.          end if;
  102.  
  103.          nextchar := 2; -- skip the one hyphen.
  104.       end if;
  105.  
  106.       --  Look at and handle the next short option-character.
  107.       declare
  108.          c : Character := argv (optind) (nextchar);
  109.          temp : Natural :=
  110.            Ada.Strings.Fixed.Index (optstring, String'(1 => c));
  111.       begin
  112.          if temp = 0 or c = ':' then
  113.             Put_Line (Standard_Error,
  114.                       argv (optind) & ": invalid option -- " & c);
  115.             optopt := c;
  116.             c := '?';
  117.             return;
  118.          end if;
  119.  
  120.          if optstring (temp + 1) = ':' then
  121.             if optstring (temp + 2) = ':' then
  122.                --  This is an option that accepts an argument optionally.
  123.                if nextchar /= argv (optind)'Length then
  124.                   optargx := To_Bounded_String
  125.                     (argv (optind) (nextchar .. argv (optind)'Length));
  126.                else
  127.                   Optarg := null;
  128.                end if;
  129.             else
  130.                --  This is an option that requires an argument.
  131.                if nextchar /= argv (optind)'Length then
  132.                   optargx := To_Bounded_String
  133.                     (argv (optind) (nextchar .. argv (optind)'Length));
  134.                   optind := optind + 1;
  135.                elsif optind = argc then
  136.                   Put_Line (Standard_Error,
  137.                             argv (optind) &
  138.                             ": option requires an argument -- " & c);
  139.                   optopt := c;
  140.                   if optstring (1) = ':'  then
  141.                      c := ':';
  142.                   else
  143.                      c := '?';
  144.                   end if;
  145.                else
  146.                   --  increment it again when taking next ARGV-elt as argument.
  147.                   optind := optind + 1;
  148.                   optargx := To_Bounded_String (argv (optind));
  149.                   optind := optind + 1;
  150.                end if;
  151.             end if;
  152.             nextchar := 0;
  153.          else -- no argument for the option
  154.             if nextchar = argv (optind)'Length then
  155.                optind := optind + 1;
  156.                nextchar := 0;
  157.             else
  158.                nextchar := nextchar + 1;
  159.             end if;
  160.          end if;
  161.  
  162.          retval := Character'Pos (c);
  163.          Optarg := new String'(To_String (optargx));
  164.          return;
  165.       end;
  166.    end Qgetopt;
  167.  
  168. end ncurses2.getopt;
  169.